home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clcs / sysdef.lisp < prev    next >
Lisp/Scheme  |  1992-06-02  |  4KB  |  130 lines
  1. ;;; -*- Mode: Lisp; Base: 10; Syntax: Common-Lisp; Package: DSYS -*-
  2.  
  3. (in-package "DSYS")
  4.  
  5. (defparameter *clcs-system-date*
  6.   "CLCS 2/1/90") ;   (For akcl-1-530)
  7.  
  8. (defsystem clcs
  9.     (:pretty-name "Common Lisp Condition System")
  10.   #+kcl (:module clos pcl (:type :system))
  11.   (:parallel
  12.    #+kcl clos
  13.    (:forms :compile (proclaim *fast-declaration*)
  14.        :load (proclaim *fast-declaration*))
  15.    (:serial
  16.     "package"
  17.     #-(or lucid excl genera cmu)
  18.     (:serial
  19.      (:load "precom")
  20.      "macros"
  21.      "restart"
  22.      "handler"
  23.      "debugger"
  24.      #+kcl "kcl-cond"
  25.      #+kcl "top-patches"
  26.      "conditions"
  27.      "condition-definitions"
  28.      (:compile "precom"))
  29.     "install")))
  30.  
  31. (defparameter *clcs-files*
  32.   '((("systems") "lisp"
  33.      "clcs")
  34.     (("clcs") "lisp"
  35.      "sysdef"
  36.      "package" "macros" "restart" "handler" "debugger"
  37.      "kcl-cond" "top-patches"
  38.      "conditions" "condition-definitions" "precom" "install")
  39.     (("clcs") nil
  40.      "clcs-readme")
  41.     (("clcs") "text"
  42.      "installing-mailed-clcs")
  43.     (("clcs" "doc") "text"
  44.      ;;"cond18" "status"
  45.      )
  46.     (("clcs" "doc") nil
  47.      ;;"clos-conditions"
  48.      )))
  49.  
  50. (defvar *clcs-dist-name* "clcs")
  51.  
  52. (defun clcs-distribution-header ()
  53.   (let* ((*subfile-default-root-pathname* 
  54.       (make-pathname :directory '(:absolute "mydirectory" "lisp")))
  55.      (dist-dir (namestring (subfile '())))
  56.      (dist-file (namestring (subfile '() :name *clcs-dist-name* :type "lisp")))
  57.      (sys-file (namestring (subfile '() :name *this-file*))))
  58.     (format nil
  59. ";;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-
  60. ;;; Common Lisp Condition System Distribution File
  61. ;;; Suppose the directory that is to contain the clcs system
  62. ;;; is ~S.
  63. ;;; To install CLCS:
  64. ;;; 
  65. ~A
  66. ;;;    (1) Put this file in ~S.
  67. ;;;    (2) Run lisp, and type:
  68. ;;;        (load ~S)
  69. ;;; To use CLCS:
  70. ;;;    (1) Run lisp, and type:
  71. ;;;        (load ~S)
  72.  
  73. " dist-dir #-akcl ""
  74. #+akcl ";;; The CLCS system redefines the functions LOAD and OPEN (adding
  75. ;;; restart handlers), and the function SYSTEM:ERROR-SET.  But AKCL is
  76. ;;; set up to compile calls to these functions into direct calls to
  77. ;;; C functions.  You can fix this by:
  78. ;;;     A. Edit the file cmpnew/lfun_list.lsp, commenting out every line
  79. ;;;        that begins with #-clcs.  
  80. ;;;     B. Remake AKCL.
  81. ;;;     C. Delete the files cmpnew/cmputil.o and lsp/debug.o
  82. ;;;        (these files call SYSTEM:ERROR-SET).
  83. ;;;     D. Remake AKCL.
  84. ;;;
  85. "
  86. dist-file dist-file sys-file)))
  87.  
  88. (defun write-clcs-distribution (&key output-file)
  89.   (dolist (sys '(clcs pcl))
  90.     (find-system sys nil))
  91.   (unless output-file 
  92.     (setq output-file (subfile '() :name *clcs-dist-name* :type "lisp")))
  93.   (write-distribution :files (append *basic-files* *clcs-files* *pcl-files*)
  94.               :output-file output-file
  95.               :header (clcs-distribution-header)
  96.               #+unix :compress-uu-split-p #+unix t))
  97.  
  98. (defun read-clcs-distribution (&key input-file)
  99.   (unless input-file
  100.     (setq input-file (subfile '() :name *clcs-dist-name* :type "lisp")))
  101.   (read-distribution :input-file input-file))
  102.  
  103. (defun clcs-users ()
  104.   (let ((users-file (subfile '("clcs") :name "users" :type "text"))
  105.     (users nil))
  106.     (when (probe-file users-file)
  107.       (with-open-file (in users-file :direction :input)
  108.     (loop (push (or (read in nil) (return nil)) users))))
  109.     (nreverse users)))
  110.  
  111. #+unix
  112. (defun mail-clcs (&key output-file (new-p :ask) (query-users-p t))
  113.   (unless output-file 
  114.     (setq output-file (subfile '() :name *clcs-dist-name* :type "lisp")))
  115.   (let ((users (clcs-users)) (mail-users nil))
  116.     (if query-users-p
  117.     (dolist (user users)
  118.       (when (y-or-n-p "Mail CLCS to ~A? " user)
  119.         (push user mail-users)))
  120.     (setq mail-users users))
  121.     (when (if (eq new-p :ask)
  122.           (y-or-n-p "~%Make a new distribution first? ")
  123.           new-p)
  124.       (write-clcs-distribution :output-file output-file))
  125.     (mail-compressed-uu-files 
  126.      :users mail-users
  127.      :file output-file
  128.      :intro-subject "How to install CLCS"
  129.      :intro-file (subfile '("clcs") :name "installing-mailed-clcs" :type "text"))))
  130.